home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / CW MacMindy 1.4 / Examples / html2txt / html2txt.dyl < prev    next >
Encoding:
Text File  |  1995-11-13  |  31.6 KB  |  832 lines  |  [TEXT/CWIE]
  1. library:    html
  2. module:        html
  3. Author:        Robert Stockton (rgs@cs.cmu.edu)
  4. synopsis:    Converts a file in WWW "HyperText Markup Language" into
  5.             formatted text.  Provides a small demo of a 'complete
  6.             application' in Dylan.
  7.  
  8. //======================================================================
  9. //
  10. // Copyright (c) 1994  Carnegie Mellon University
  11. // All rights reserved.
  12. // 
  13. // Use and copying of this software and preparation of derivative
  14. // works based on this software are permitted, including commercial
  15. // use, provided that the following conditions are observed:
  16. // 
  17. // 1. This copyright notice must be retained in full on any copies
  18. //    and on appropriate parts of any derivative works.
  19. // 2. Documentation (paper or online) accompanying any system that
  20. //    incorporates this software, or any part of it, must acknowledge
  21. //    the contribution of the Gwydion Project at Carnegie Mellon
  22. //    University.
  23. // 
  24. // This software is made available "as is".  Neither the authors nor
  25. // Carnegie Mellon University make any warranty about the software,
  26. // its performance, or its conformity to any specification.
  27. // 
  28. // Bug reports, questions, comments, and suggestions should be sent by
  29. // E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  30. //
  31. //======================================================================
  32.  
  33. //======================================================================
  34. // This program is a filter which converts text in WWWs "HyperText Markup
  35. // Language" into simple formatted text.  Although it is a complete and useful
  36. // application, it is included in this distribution primarily as a
  37. // demonstration of a "real" (albeit small) Dylan (tm) program.
  38. //
  39. // Usage is typical for a UNIX (tm) program.  It may be invoked either with a
  40. // set of files on the command line:
  41. //   mindy -f html2txt.dbc file1.html file2.html ....
  42. // or with no arguments, in which case it reads from "standard input".  At
  43. // present, it accepts no command line switches, although the behavior may be
  44. // changed by changing several constant declarations towards the top of this
  45. // source file.
  46. //
  47. // On most unix systems you should be able to make it into an executable
  48. // script by prepending the the line
  49. //   #!BINDIR/mindy -f
  50. // to the compiled "dbc" file.  You must, of course, remember to specify the
  51. // MINDYPATH environment variable so that it points to the libraries "dylan",
  52. // "streams", "collection-extensions", and "string-extensions".
  53. //
  54. // The basic translation strategy used by html2txt is to scan the file line by
  55. // line, looking for HTML "tags" and accumulating text that lies between any
  56. // two tags.  For each tag type, there is a set of routines (stored in tables)
  57. // which define the appropriate actions for starting and ending the
  58. // "environment" defined by the tag and for dumping the collected text from
  59. // within that environment as formatted text.  A basic control loop in
  60. // "process-HTML" is responsible for calling the appropriate tag actions.
  61. // This routine may be called recusively by some of the tag actions.
  62. //
  63. // The "interface" between adjacent environments is handled via the "blank"
  64. // parameter which is passed around extensively.  This variable states whether
  65. // a blank line has just been printed.  Thus environments which believe that
  66. // they must be preceded or followed by a blank line can determine whetehr
  67. // they must do anything about it, and we lessen the risk that multiple
  68. // routines will emit blank lines when we only want a maximum of one.
  69. //
  70. // The primary advantage of this organization is that it allows the
  71. // specialized actions for a single tag to be grouped together, and allows new
  72. // tags to be cleanly added.  It benefits greatly from Dylan's ability to
  73. // create anonymous methods and manipulate them as first class data objects,
  74. // as well as from the rich set of available collection types.
  75. //======================================================================
  76.  
  77. // Because the entire application is contained in a single file, it is easiest
  78. // to define its library and module "inline".  This capability may not be
  79. // supported by all Dylan implementations, since the "file exchange format" is
  80. // not terribly well defined at present.
  81.  
  82. define library html
  83.   use dylan;
  84.   use streams;
  85.   use collection-extensions;
  86.   use string-extensions;
  87. end library html;
  88.  
  89. define module html
  90.   use dylan;
  91.   
  92.   // A few basic definitions not present in the Dylan spec
  93.   use extensions, import: {<boolean>, main};
  94.   
  95.   // Additional collection classes and operations from "collection-extensions"
  96.   use subseq;
  97.   use self-organizing-list;
  98.  
  99.   // From string-extensions:
  100.   use substring-search;
  101.   
  102.   // I/O support from the "streams" library
  103.   use streams;
  104.   use standard-io;
  105.   
  106.   export html2text;
  107. end module html;
  108.  
  109. // Basic constants
  110. define constant <strings> = <stretchy-vector>;
  111. define variable *linelen* :: <integer> = 78;
  112. define variable *margin* :: <integer> = 2;
  113.  
  114. define variable *H1cap* :: <boolean> = #t;
  115. define variable *H1under* :: <boolean> = #t;
  116. define variable *H2cap* :: <boolean> = #t;
  117. define variable *H2under* :: <boolean> = #t;
  118. define variable *Bcap* :: <boolean> = #t;
  119. define variable *Icap* :: <boolean> = #t;
  120.  
  121. // Internal constants
  122. define variable Pre-Count :: <integer> = 0;
  123. define variable prefix :: <string> = "";
  124. define variable counter :: <integer> = 0;
  125.  
  126. // We can use hash tables for looking up tag processing routines, but "self
  127. // organizing lists" tend to provide better performance in this case.  Since
  128. // they are completely interchangeable, you can try switching the definition
  129. // here to swap in the "standard" table support instead.
  130.  
  131. define constant <tag-table> = <self-organizing-list>;
  132. // define constant <tag-table> = <object-table>;
  133.  
  134.  
  135. //////////////////////////////////////////////////////////////////////////
  136. //                   String Utilities                //
  137. //////////////////////////////////////////////////////////////////////////
  138.  
  139. // Find the index of first element (after "from") of a sequence which
  140. // satisfies the given predicate.  (Like find-key, but guaranteed sequential
  141. // and accepts start: and end: rather than skip:.)
  142.  
  143. // This program makes heavy use of start: and end: keywords (in order to avoid
  144. // copying subsequences).  Find-key would have been completely unsuitable for
  145. // this unless we used <subsequence>s to refer to slices of existing
  146. // sequences, and even then the efficiency penalty would have been high.  It
  147. // therefore seemed better to simply define new routines to do "the right
  148. // thing". 
  149. define method sfind(seq :: <sequence>, pred?, 
  150.             #key start: start = 0,
  151.                  end: last, failure: fail)
  152.   block (return)
  153.     let last = if (last) min(last, size(seq)) else size(seq) end if;
  154.     for (i :: <integer> from start below last)
  155.       if (pred?(seq[i])) return(i)  end if;
  156.     finally 
  157.       fail;
  158.     end for;
  159.   end block;
  160. end method sfind;
  161.  
  162. // Like sfind, but goes backward from the end (or from before end:).
  163. define method rsfind(seq :: <sequence>, pred?,
  164.              #key start: start = 0,
  165.                   end: last, failure: fail)
  166.   block (return)  
  167.     let last = if (last) min(last, size(seq)) else size(seq) end if;
  168.     for (i from last - 1 to start by -1) 
  169.       if (pred?(seq[i])) return(i)  end if;
  170.     finally 
  171.       fail;
  172.     end for;
  173.   end block;
  174. end method rsfind;
  175.  
  176. // The notation "'!' * 5" is a good way to create a string of repeated
  177. // characters.  This variety of overloaing is becoming popular in several
  178. // modern languages (i.e. C++, Perl, and Ada).
  179. define method \*(ch :: <character>,
  180.          times :: <integer>)  => (result :: <byte-string>);
  181.   make(<byte-string>, size: times, fill: ch) 
  182. end method \*;
  183.  
  184. ////////////////////////////////////////////////////////////////////////
  185. //                 Basic HTML Utilities              //
  186. ////////////////////////////////////////////////////////////////////////
  187.  
  188. // Simply a conventient shorthand for writing to *standard-output*.
  189. define method write-string(string :: <string>)
  190.   write(string, *standard-output*);
  191. end method write-string;
  192.  
  193. // Print a line according to *margin* and *linelen*.  Add special handling for
  194. // *prefix* hack.  Streams don't automatically flush output at the ends of
  195. // lines, so we flush the output ourselves to allow the output to be viewed
  196. // interactively. 
  197. define method print-with-prefix(str :: <string>, #rest args) 
  198.   for (i from 1 to *margin* - size(prefix))
  199.     write(' ', *standard-output*);
  200.   end for;
  201.   write-string(prefix); 
  202.   apply(write-line, str, *standard-output*, args);
  203.   prefix := "" ;
  204.   force-output(*standard-output*);
  205. end method print-with-prefix;
  206.  
  207. // As mentioned above, "tag action routines" are stored in tables for easy
  208. // reference.  They are keyed by symbols corresponding to the tag (i.e.
  209. // #"text"). 
  210. define constant add-text-table :: <tag-table> = make(<tag-table>);
  211.  
  212. // The heavy duty search and replace operations in "add-text" are in the
  213. // critical path, so it is worth optimizing these by pre-computing the search
  214. // tables.  For more details, look at the "string-search" module in
  215. // "extensions". 
  216. define constant tab-to-space
  217.   = make-substring-replacer("\t", replace-with: " ");
  218. define constant convert-lt
  219.   = make-substring-replacer("<", replace-with: "<");
  220. define constant convert-gt
  221.   = make-substring-replacer(">", replace-with: ">");
  222. define constant convert-amp
  223.   = make-substring-replacer("&", replace-with: "&");
  224.  
  225. // Accumulates text within a single tag environment.  The appropriate tag
  226. // action routine is called to transform the given text.  This may be
  227. // "identity", "as-uppercase", or any other arbitrary action.
  228. // This routine also transforms "quoted characters" (such as "<" for '<')
  229. // into their ascii equivalents and crunches tabs down into spaces.
  230. define method add-text(tag :: <symbol>, text :: <strings>,
  231.                new-text :: <string>) => (result :: <strings>);
  232.   // replace-substring only works on <byte-string>s.
  233.   let new-text :: <string> =
  234.     as(<byte-string>, new-text);
  235.   let Tab-Free :: <string> =
  236.     if (Pre-Count = 0)
  237.       tab-to-space(new-text);
  238.     else
  239.       new-text;
  240.     end if;
  241.   let AMP :: <string> = convert-amp(convert-lt(convert-gt(Tab-Free)));
  242.   
  243.   let new-text = element(add-text-table, tag, default: identity)(AMP);
  244.   
  245.   if (empty?(new-text)) text else add!(text, new-text) end;
  246. end method add-text;
  247.  
  248. // Special processing is required when newlines are encountered in the input
  249. // stream.  If we are in a "<PRE>" environment, then we simply include a
  250. // newline in the output.  If we are in any other environment, we must guess
  251. // the correct number of spaces to put in based upon the punctuation of the
  252. // previous line.
  253. define method add-eol(text :: <strings>) => (result :: <strings>);
  254.   if (Pre-Count > 0) 
  255.     add!(text, "\n") 
  256.   else
  257.     let Prev-Str = last(text, default: "");
  258.     if (Prev-Str.empty?)
  259.       text;
  260.     else
  261.       let space = 
  262.     select (Prev-Str.last)
  263.       '.', ':', '!', '?' =>
  264.         "  ";
  265.       '-', ' ' =>
  266.         "";
  267.       otherwise =>
  268.         " ";
  269.     end select;
  270.       add!(text, space);
  271.     end if;
  272.   end if 
  273. end method add-eol;
  274.  
  275. // The "break-up" routines produce and print appropriate formatted text from
  276. // the accumulated data.  The action defaults to the #"text" action, which
  277. // breaks the text into lines (at word boundaries)according to the defined
  278. // margins.  "break-up" then clears the accumulated text before returning
  279. // control to the main loop.
  280. define constant break-up-table :: <tag-table> = make(<tag-table>);
  281. define method break-up(tag :: <symbol>, text :: <strings>, 
  282.                blank :: <boolean>,
  283.                want-blank :: <boolean>) => (result :: <boolean>);
  284.   let full-text = if (text.empty?) "" else apply(concatenate, text) end;
  285.   block ()
  286.     break-up-table[tag](full-text, blank, want-blank);
  287.   exception <error>
  288.     break-up-table[#"TEXT"](full-text, blank, want-blank);
  289.   cleanup
  290.     size(text) := 0;
  291.   end block;
  292. end method break-up;
  293.  
  294. // Tag close defines the appropriate action to take at the end of an
  295. // environment (i.e. when encountering "</PRE>".  This may be a null action,
  296. // or may call "break-up" to dump the accumulated text, or may perform any
  297. // other arbitrary action.
  298. define constant tag-close-table :: <tag-table> = make(<tag-table>);
  299. define method tag-close(tag :: <symbol>, close :: <symbol>,
  300.             text :: <strings>, blank :: <boolean>)
  301.     => (result :: <boolean>);
  302.   if (tag ~= close) 
  303.     signal(concatenate("Tag mismatch: <", as(<string>, tag), "> vs. </",
  304.                as(<string>, close), ">.\n"))  
  305.   end if;
  306.   block ()
  307.     tag-close-table[tag](tag, text, blank);
  308.   exception <error>
  309.     tag-close-table[#"TEXT"](tag, text, blank);
  310.   end block;
  311. end method tag-close;
  312.  
  313. // Tag start defines the appropriate action to take at the beginning of an
  314. // environment (i.e. when encountering "<PRE>".  This may be a null action,
  315. // or may call "break-up" to dump the accumulated text, or may perform any
  316. // other arbitrary action.
  317. define constant tag-start-table :: <tag-table> = make(<tag-table>);
  318. define method tag-start(New-Tag :: <symbol>, Old-Tag :: <symbol>,
  319.             Out-Text :: <strings>, Current-Text :: <string>, 
  320.             File :: <stream>, blank :: <boolean>)
  321.     => (New-Text :: <string>, blank :: <boolean>);
  322.   let fun = block ()
  323.           tag-start-table[New-Tag];
  324.         exception <error>
  325.           signal("Unknown tag type: <%=>\n", New-Tag);
  326.           tag-start-table[#"TEXT"];
  327.         end block;
  328.   fun(New-Tag, Old-Tag, Out-Text, Current-Text, File, Blank);
  329. end method tag-start;
  330.  
  331. // This routine is called at "load time" to build the tag action tables.  Note
  332. // that "reasonable" defaults are defined for all actions so that only the
  333. // "specialized" actions for any given environment need be specified.
  334. define method add-tag(tags :: <sequence>,
  335.               #key add-text: AT = identity,
  336.                    break-up: BU = break-up-table[#"TEXT"],
  337.                    tag-close: TC = tag-close-table[#"TEXT"],
  338.                    tag-start: TS = tag-start-table[#"TEXT"])
  339.   for (tag in tags)
  340.     let Tag-Symbol = as(<symbol>, tag);
  341.     add-text-table[Tag-Symbol] := AT;
  342.     break-up-table[Tag-Symbol] := BU;
  343.     tag-close-table[Tag-Symbol] := TC;
  344.     tag-start-table[Tag-Symbol] := TS;
  345.   end for;
  346. end method add-tag;
  347.  
  348. ////////////////////////////////////////////////////////////////////////
  349. //                 Main Driver Routines              //
  350. ////////////////////////////////////////////////////////////////////////
  351.  
  352. // This is the workhorse routines.  It reads in new data, searches for tags,
  353. // and dispatches the appropriate "add-text", "tag-start", and "tag-close"
  354. // routines.  It also attempts to unwind gracefully when it encounters the end
  355. // of the file, since many HTML data files fail to terminate all environments.
  356. define method process-HTML(Tag :: <symbol>, Out-Text :: <strings>, 
  357.                Current-Text :: <string>, File :: <stream>,
  358.                blank :: <boolean>)
  359.     => (Current-Text :: <string>, blank :: <boolean>);
  360.   
  361.   local method is-space(ch) ch == ' ' | ch == '\t' end method;
  362.   local method tag-end(ch) ch == ' ' | ch == '\t' | ch == '>' end method;
  363.   local method not-space(ch) ch ~= ' ' & ch ~= '\t' end method;
  364.   
  365. //  break("process-HTML");
  366.   
  367.   block (return)
  368.     while (#t)
  369.   
  370.       // keep crunching until EOF causes us to call "return"
  371.       let Start-Tag = sfind(Current-Text, curry(\==, '<'));
  372.       if (Start-Tag)
  373.         // There is a tag on this line, so we accumulate the text which
  374.         // precedes it and then invoke the appropriate tag actions.
  375.         Out-Text := add-text(Tag, Out-Text,
  376.                     subsequence(Current-Text, end: Start-Tag));
  377.     
  378.         // If a newline occurs within a tag, we must keep reading until we get
  379.         // the rest of the tag.  Whitespace is simply used as a separator, so
  380.         // we substitute a space for the newline.
  381.         let End-Tag =
  382.           for (index = sfind(Current-Text, curry(\==, '>'), start: Start-Tag)
  383.               then sfind(Current-Text, curry(\==, '>'), start: Start-Tag),
  384.               until index)
  385.                 Current-Text := concatenate(Current-Text, " ", read-line(File));
  386.               finally index;
  387.           end for;
  388.     
  389.         // Find the complete tag and figure out whether it is "opening" or
  390.         // "closing" an environment.
  391.         let first = sfind(Current-Text, not-space, start: Start-Tag + 1);
  392.         let Is-Close = Current-Text[first] = '/'; 
  393.         if (Is-Close)
  394.           first := sfind(Current-Text, not-space, start: first + 1)
  395.         end if; 
  396.     let New-Tag =
  397.       as(<symbol>, copy-sequence(Current-Text, start: first, 
  398.                      end: sfind(Current-Text, tag-end,
  399.                         start: first)));
  400.     // Call the appropriate action for the tag.  This may invoke
  401.     // a recursive call to "process-HTML" for start tags and will exit
  402.     // this recusive call for closing tags.
  403.     Current-Text := copy-sequence(Current-Text, start: End-Tag + 1);
  404.     if (Is-Close)
  405.       return(Current-Text, tag-close(Tag, New-Tag, Out-Text, blank));
  406.     else 
  407.       let (New-Text, NewBlank) = 
  408.         tag-start(New-Tag, Tag, Out-Text, Current-Text, File, blank);
  409.       Current-Text := New-Text;
  410.       blank := NewBlank; 
  411.     end if;
  412.       else
  413.     // Process newlines.  We ignore indentation in the next line unless we
  414.     // are inside a "<PRE>" environment.
  415.     Out-Text := add-eol(add-text(Tag, Out-Text, Current-Text));
  416.     let (New-Text, eof) = read-line(File);
  417.     let First-Real = if (Pre-Count = 0)
  418.                sfind(New-Text, not-space, failure: 0);
  419.              else 0
  420.              end if;
  421.     Current-Text := if (First-Real > 0)
  422.               copy-sequence(New-Text, start: First-Real);
  423.             else
  424.               New-Text;
  425.             end if;
  426.       end if;
  427.     end while;
  428.   exception <end-of-file>
  429.     // End of file processing.  Dump accumulated text and then exit.
  430.     let blank = break-up(Tag, Out-Text, blank, #f);
  431.     values("", blank);
  432.   end block 
  433. end method process-HTML;
  434.  
  435. // specialized routines to open various sourts of streams and invoke
  436. // "process-HTML".
  437. define method html2text(fd :: <stream>) => ();
  438.   process-HTML(#"TEXT", make(<strings>), "", fd, #t);
  439.   force-output(*standard-output*);
  440. end method html2text;
  441.  
  442. define method html2text(file :: <string>) => ();
  443.   let stream = make(<file-stream>, name: file);
  444.   html2text(stream);
  445. end method html2text;
  446.  
  447. define method html2text(file == #t) => ();
  448.   html2text(make(<fd-stream>, fd: 0));
  449. end method html2text;
  450.  
  451. // Trivial main program -- just invokes "html2text" which in turn invokes
  452. // "process-HTML".  Note that we had to import the generic function "main"
  453. // from module "extensions" in library "dylan".  This interface is Mindy
  454. // specific. 
  455. define method main (argv0, #rest args) => ();
  456.   if (empty?(args))
  457.     html2text(#t);
  458.   else
  459.     map(html2text, args);
  460.   end if;
  461. end method main;
  462.  
  463. ////////////////////////////////////////////////////////////////////////
  464. //            Specific Environment Routines              //
  465. ////////////////////////////////////////////////////////////////////////
  466.  
  467. // The anonymous methods here implement the appropriate tag actions for all of
  468. // the tags currently supported.  Some are quite straightforward, while others
  469. // may require a twisted mind to "properly appreciate" them.  This
  470. // organization does, at least, allow the processing of most tags to be
  471. // isolated so that you needn't grok all the code at once.
  472.  
  473. add-tag(#["TEXT"],           // Default environment
  474.     // Performs a "paragraph break" and recursively processes the new
  475.     // environment
  476.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>, 
  477.                Out-Text :: <strings>, Current-Text :: <string>,
  478.                File :: <stream>, blank :: <boolean>)
  479.                => (result :: <string>, blank :: <boolean>);
  480.              let blank = break-up(Old-Tag, Out-Text, blank, #t);
  481.              process-HTML(New-Tag, Out-Text, Current-Text,
  482.                   File, blank);
  483.            end method,
  484.     // Performs a "paragraph break" and returns to the enclosing
  485.     // environment
  486.     tag-close: method (tag :: <symbol>, text :: <strings>,
  487.                blank :: <boolean>) => (result :: <boolean>);
  488.              break-up(tag, text, blank, #t);
  489.            end method,
  490.     // Breaks "text" into lines according to *margin* and *linelen*.
  491.     // Parameters blank and want-blank say whether there is a blank line
  492.     // before the current text and whether there should be one after the
  493.     // current text.  The return value tells whether a blank line was
  494.     // printed.
  495.     break-up: method (text :: <string>, blank :: <boolean>, 
  496.               want-blank :: <boolean>)  => (result :: <boolean>);
  497.             let first = sfind(text, curry(\~=, ' ')); 
  498.             if (~first) 
  499.               if (want-blank & ~blank) write-string("\n")  end if;
  500.               blank | want-blank 
  501.             else
  502.               let Text-Size = size(text);
  503.               let Find-Break = 
  504.             method (first, last)
  505.               if (last >= Text-Size)
  506.                 Text-Size;
  507.               else 
  508.                 let find = rsfind(text, curry(\=, ' '),
  509.                           start: first, end: last); 
  510.                 if (find)   
  511.                   rsfind(text, curry(\~=, ' '), 
  512.                      start: first, end: find) + 1 
  513.                 else 
  514.                   sfind(text, curry(\=, ' '), start: first)
  515.                 | size(text)
  516.                 end if
  517.               end if
  518.             end method; 
  519.               while (first)
  520.             let last = Find-Break(first,
  521.                           first + *linelen* - *margin*);
  522.             print-with-prefix(text, start: first, end: last); 
  523.             first := sfind(text, curry(\~=, ' '), start: last + 1)
  524.               end while; 
  525.               if (want-blank) write-string("\n")  end if; 
  526.               want-blank 
  527.             end if 
  528.           end method);
  529.  
  530. // This tag action is used for many different tags -- it simply invokes
  531. // "process-HTML" recursively without doing anything special to the
  532. // accumulated text.  This is handy for "lightweight" enviromentents like
  533. // "<I>". 
  534. define constant tag-start-recurse =
  535.   method (New-Tag :: <symbol>, Old-Tag :: <symbol>, 
  536.       Out-Text :: <strings>, Current-Text :: <string>, 
  537.       File :: <stream>, blank :: <boolean>)
  538.       => (result :: <string>, blank :: <boolean>);
  539.     process-HTML(New-Tag, Out-Text, Current-Text, File, blank);
  540.   end method;
  541.  
  542. // This tag action is a logical partner for "tag-start-recurse".  It simply
  543. // exits so that control will return to an inclosing "process-HTML" call
  544. // without distrubing the accumulated text.
  545. define constant tag-close-nothing =
  546.   method (tag :: <symbol>, Out-Text :: <strings>, blank :: <boolean>)
  547.     blank;
  548.   end method;
  549.  
  550. // Specialized "add-text" methods provide EMPHASIZED versions of "<B>" or
  551. // "<I>" style environments.
  552. add-tag(#["I", "EM", "CITE", "VAR", "DFN"],
  553.     add-text: method(text :: <string>) => (result :: <string>);
  554.               if (*Icap*) as-uppercase(text) else text end
  555.           end method,
  556.     tag-start: tag-start-recurse,
  557.     tag-close: tag-close-nothing);
  558.  
  559. add-tag(#["B", "STRONG"],
  560.     add-text: method(text :: <string>) => (result :: <string>);
  561.               if (*Bcap*) as-uppercase(text) else text end
  562.           end method,
  563.     tag-start: tag-start-recurse,
  564.     tag-close: tag-close-nothing);
  565.  
  566. // Anchors do nothing at all.
  567. add-tag(#["A", "HEAD", "BODY", "UNKNOWN", "TT", "CODE", "SAMP", "KBD"],
  568.     tag-start: tag-start-recurse,
  569.     tag-close: tag-close-nothing);
  570.  
  571. // Titles are eliminated entirely -- add-text simply "adds" an empty string.
  572. add-tag(#["TITLE"], 
  573.     add-text: method(text :: <string>) => (res :: <string>); "" end method,
  574.     tag-start: tag-start-recurse,
  575.     tag-close: tag-close-nothing);
  576.  
  577. // For un-bracketed environments like "<P>", "<BR>", etc. we must make sure
  578. // "tag-start" does not start a recursive call to "process-HTML".  We may or
  579. // may not want to dump accumulated text.
  580. add-tag(#["!"],
  581.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>, 
  582.                Out-Text :: <strings>, Current-Text :: <string>,
  583.                File :: <stream>, blank :: <boolean>)
  584.                => (result :: <string>, blank :: <boolean>);
  585.              values(Current-Text, blank);
  586.            end method);
  587.  
  588. add-tag(#["P"],
  589.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>, 
  590.                Out-Text :: <strings>, Current-Text :: <string>,
  591.                File :: <stream>, blank :: <boolean>)
  592.                => (result :: <string>, blank :: <boolean>);
  593.              values(Current-Text,
  594.                 break-up(Old-Tag, Out-Text, blank, #t));
  595.            end method);
  596.  
  597. add-tag(#["BR"], 
  598.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>, 
  599.                Out-Text :: <strings>, Current-Text :: <string>,
  600.                File :: <stream>, blank :: <boolean>)
  601.                => (result :: <string>, blank :: <boolean>);
  602.              if (Pre-Count > 0)
  603.                add-eol(Out-Text);
  604.                values(Current-Text, blank);
  605.              else
  606.                values(Current-Text,
  607.                   break-up(Old-Tag, Out-Text, blank, #f));
  608.              end if;
  609.            end method);
  610.  
  611. add-tag(#["HR"],
  612.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  613.                Out-Text :: <strings>, Current-Text :: <string>,
  614.                File :: <stream>, blank :: <boolean>)
  615.                => (result :: <string>, blank :: <boolean>);
  616.              break-up(Old-Tag, Out-Text, blank, #t);
  617.              write-line(concatenate('-' * *linelen*, "\n"),
  618.                 *standard-output*);
  619.              values(Current-Text, #t);
  620.            end method);
  621.  
  622. add-tag(#["IMG"],
  623.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  624.                Out-Text :: <strings>, Current-Text :: <string>,
  625.                File :: <stream>, blank :: <boolean>)
  626.                => (result :: <string>, blank :: <boolean>);
  627.              break-up(Old-Tag, Out-Text, blank, #t);
  628.              write-line(concatenate(' ' * *margin* + 4,
  629.                         "*** INLINE IMAGE IGNORED ***\n"),
  630.                 *standard-output*);
  631.              values(Current-Text, #t);
  632.            end method);
  633.  
  634. // Preformatted text is tricky.  First we dump accumulated text.  Then we
  635. // increment the global variable "Pre-Count" which enables magic behavior in
  636. // several standard routines.  Finally, when the environment is closed, we
  637. // split the output around the newlines and do line-by-line output so that the
  638. // left margin will be observed.
  639. add-tag(#["PRE"],
  640.     break-up: method (text :: <string>, blank :: <boolean>,
  641.               want-blank :: <boolean>) => (result :: <boolean>);
  642.             unless(blank) write('\n', *standard-output*); end;
  643.             let first = sfind(text, curry(\~=, '\n'));
  644.             let last = rsfind(text,
  645.                       complement(rcurry(member?, "\n ")));
  646.             if (last)
  647.               while (first < last)
  648.             let endline = sfind(text, curry(\=, '\n'),
  649.                         start: first, failure: last + 1);
  650.             print-with-prefix(text, start: first, end: endline);
  651.             first := endline + 1;
  652.               end while;
  653.             end if;
  654.             write-string("\n");
  655.             #t
  656.           end method,
  657.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  658.                Out-Text :: <strings>, Current-Text :: <string>,
  659.                File :: <stream>, blank :: <boolean>)
  660.                => (result :: <string>, blank :: <boolean>);
  661.              let blank = break-up(Old-Tag, Out-Text, blank, #t);
  662.              block ()
  663.                Pre-Count := Pre-Count + 1;
  664.                process-HTML(New-Tag, Out-Text, Current-Text,
  665.                     File, blank);
  666.              cleanup
  667.                Pre-Count := Pre-Count - 1;
  668.              end block;
  669.            end method);
  670.  
  671. // Since the following methods add nested indentation levels, we create a
  672. // stack for the margins.  A "document state" record might be cleaner, but is
  673. // probably overkill for this particular application.
  674. define constant margins :: <Deque> = make(<Deque>);
  675.  
  676. add-tag(#["UL", "OL", "MENU", "DL", "BLOCKQUOTE"],
  677.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  678.                Out-Text :: <strings>, Current-Text :: <string>,
  679.                File :: <stream>, blank :: <boolean>)
  680.                => (result :: <string>, blank :: <boolean>);
  681.              break-up(Old-Tag, Out-Text, blank, #t);
  682.              let OldCounter = counter;
  683.              block ()
  684.                push(margins, *margin*);
  685.                *margin* := *margin* + 4;
  686.                counter := 0;
  687.                process-HTML(New-Tag, Out-Text, Current-Text,
  688.                     File, blank);
  689.              cleanup
  690.                *margin* := pop(margins);
  691.                counter := OldCounter;
  692.              end block;
  693.            end method);
  694.  
  695. // The "<LI>" tag causes bullets or numbers to be printed before the
  696. // immediately following text.  We use a global "prefix" variable to magically
  697. // change the behavior of the next call to "print-with-prefix".  The precise
  698. // choice of prefix depends upon the enclosing environment.
  699. add-tag(#["LI"],
  700.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  701.                Out-Text :: <strings>, Current-Text :: <string>,
  702.                File :: <stream>, blank :: <boolean>)
  703.                => (result :: <string>, blank :: <boolean>);
  704.              let blank = break-up(Old-Tag, Out-Text, blank, #f);
  705.              if (Old-Tag = #"OL")
  706.                counter := counter + 1;
  707.                prefix := copy-sequence("0. ");
  708.                prefix[0] := as(<character>,
  709.                        counter + as(<integer>, '0'));
  710.              else
  711.                prefix := "* ";
  712.              end if;
  713.              values(Current-Text, blank);
  714.            end method);
  715.  
  716. // In "<DL>" environments, we must simply switch the left margin back and
  717. // forth between "unindented" and "indented" depending on whether we are
  718. // currently processing a "term" or a "definition".
  719. add-tag(#["DT"],
  720.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  721.                Out-Text :: <strings>, Current-Text :: <string>,
  722.                File :: <stream>, blank :: <boolean>)
  723.                => (result :: <string>, blank :: <boolean>);
  724.              let blank = break-up(Old-Tag, Out-Text, blank, #f);
  725.              *margin* := first(margins);
  726.              values(Current-Text, blank);
  727.            end method);
  728.  
  729. add-tag(#["DD"],
  730.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  731.                Out-Text :: <strings>, Current-Text :: <string>,
  732.                File :: <stream>, blank :: <boolean>)
  733.                => (result :: <string>, blank :: <boolean>);
  734.              let blank = break-up(Old-Tag, Out-Text, blank, #f);
  735.              *margin* := first(margins) + 4;
  736.              values(Current-Text, blank);
  737.            end method);
  738.  
  739. // Headers may centered and/or underlined and ignore margins.  They must still
  740. // be broken up into lines, although we use a shorter line-length.
  741. add-tag(#["H1"],
  742.     break-up: method (text :: <string>, blank :: <boolean>,
  743.               want-blank :: <boolean>)  => (result :: <boolean>);
  744.             unless(blank) write('\n', *standard-output*); end;
  745.             let first = sfind(text, curry(\~=, ' ')); 
  746.             let Text-Size = size(text);
  747.             let Find-Break = 
  748.               method (first, last)
  749.             if (last >= Text-Size)
  750.               Text-Size;
  751.             else 
  752.               let find = rsfind(text, curry(\=, ' '),
  753.                         start: first, end: last); 
  754.               if (find)   
  755.                 rsfind(text, curry(\~=, ' '), 
  756.                    start: first, end: find) + 1 
  757.               else 
  758.                 sfind(text, curry(\=, ' '), start: first)
  759.                   | size(text)
  760.               end if
  761.             end if
  762.               end method; 
  763.             let Max-Length = 0;
  764.             while (first)
  765.               let last = Find-Break(first, first + *linelen* - 20);
  766.               Max-Length := max(Max-Length, last - first);
  767.               write-string(' ' * truncate/(*linelen* + first - last,
  768.                            2));
  769.               write-line(text, *standard-output*,
  770.                  start: first, end: last); 
  771.               first := sfind(text, curry(\~=, ' '), start: last + 1)
  772.             end while;
  773.             if (*H1under*)
  774.               write-string(' ' * truncate/(*linelen* - Max-Length, 2));
  775.               write-line('=' * Max-Length, *standard-output*); 
  776.             end if;
  777.             if (want-blank) write-string("\n")  end if; 
  778.             want-blank 
  779.           end method);
  780.  
  781. add-tag(#["H2"],
  782.     break-up: method (text :: <string>, blank :: <boolean>,
  783.               want-blank :: <boolean>)  => (result :: <boolean>);
  784.             unless(blank) write('\n', *standard-output*); end;
  785.             let first = sfind(text, curry(\~=, ' ')); 
  786.             let Text-Size = size(text);
  787.             let Find-Break = 
  788.               method (first, last)
  789.             if (last >= Text-Size)
  790.               Text-Size;
  791.             else 
  792.               let find = rsfind(text, curry(\=, ' '),
  793.                         start: first, end: last); 
  794.               if (find)   
  795.                 rsfind(text, curry(\~=, ' '), 
  796.                    start: first, end: find) + 1 
  797.               else 
  798.                 sfind(text, curry(\=, ' '), start: first)
  799.                   | size(text)
  800.               end if
  801.             end if
  802.               end method; 
  803.             let Max-Length = 0;
  804.             while (first)
  805.               let last = Find-Break(first, first + *linelen* - 20);
  806.               Max-Length := max(Max-Length, last - first);
  807.               write-line(text, *standard-output*,
  808.                  start: first, end: last); 
  809.               first := sfind(text, curry(\~=, ' '), start: last + 1)
  810.             end while;
  811.             if (*H2under*)
  812.               write-line('-' * Max-Length, *standard-output*);
  813.               #f;
  814.             else
  815.               write('\n', *standard-output*);
  816.               #t
  817.             end if;
  818.           end method);
  819.  
  820. add-tag(#["H3", "H4", "H5", "H6"],
  821.     break-up: method (text :: <string>, blank :: <boolean>,
  822.               want-blank :: <boolean>)  => (result :: <boolean>);
  823.             unless(blank) write('\n', *standard-output*); end;
  824.             block ()
  825.               push(margins, *margin*);
  826.               *margin* := 0;
  827.               add-text-table[#"TEXT"](text, #t, want-blank);
  828.             cleanup
  829.               *margin* := pop(margins);
  830.             end;
  831.           end method);
  832.